(DEFPROP LC4FCNS
 (LC4FCNS COMPL
	  COMP
	  SUBSTACK
	  PRUP
	  MKPUSH
	  COMPEXP
	  STACKUP
	  CCCHAIN
	  COMPC
	  COMCOND
	  COMPLISA
	  CCOUNT
	  LOADAC
	  COMPLIS
	  CLASSIFY
	  CLASS1
	  CLASS2
	  MKJRST
	  COMBOOL
	  COMPANDOR
	  COMPANDOR1
	  GENSYM1
	  FLAT)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (PROG	(Z)
	(EVAL (CONS (QUOTE OUTPUT) (CONS (QUOTE DSK:) (LIST (CONS (CAR FILE) (QUOTE LAP))))))
	(EVAL (CONS (QUOTE INPUT) (CONS (QUOTE DSK:) FILE)))
	(INC (QUOTE T) NIL)
	(OUTC T NIL)
   LOOP	(SETQ Z (ERRSET (READ)))
	(COND ((ATOM Z) (GO DONE)) ((QUOTE T) (QUOTE NIL)))
	(SETQ Z (CAR Z))
	(COND ((EQ (CAR Z) (QUOTE DE))
	       (PROG (PROG)
		     (SETQ PROG (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
		     (MAPC (FUNCTION PRINT) PROG)
		     (OUTC NIL NIL)
		     (PRINT (LIST (CADR Z) (LENGTH PROG)))
		     (OUTC T NIL)))
	      (T (PRINT Z)))
	(GO LOOP)
   DONE	(OUTC NIL T)
	(INC NIL T)
	(RETURN (QUOTE ENDCOMP))))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(VPR N)
    (APPEND (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
	    (MKPUSH N 1)
	    (COMPEXP EXP (MINUS N) VPR)
	    (SUBSTACK N)
	    (QUOTE ((POPJ P) NIL))))
   (PRUP VARS 1)
   (LENGTH VARS)))
EXPR)

(DEFPROP SUBSTACK
 (LAMBDA (N) (COND ((EQ N 0) NIL) (T (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE C) 0 0 N N))))))
EXPR)

(DEFPROP PRUP
 (LAMBDA (VARS N) (COND ((NULL VARS) NIL) (T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (PLUS N 1))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA (N M) (COND ((LESSP N M) NIL) (T (CONS (LIST (QUOTE PUSH) (QUOTE P) M) (MKPUSH N (PLUS M 1))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((OR (EQ EXP (QUOTE T)) (NUMBERP EXP)) (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP) (LIST (LIST (QUOTE MOVE) 1 (PLUS M (CDR (ASSOC* EXP VPR))) (QUOTE P))))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST (LIST (QUOTE HLRZ@) 1 (PLUS M (CDR (ASSOC* (CADR EXP) VPR))) (QUOTE P))))
	       (T (APPEND (COMPEXP (CADR EXP) M VPR) (QUOTE ((HLRZ@ 1 1)))))))
	((EQ (CAR EXP) (QUOTE CDR))
	 (COND ((ATOM (CADR EXP))
		(LIST (LIST (QUOTE HRRZ@) 1 (PLUS M (CDR (ASSOC* (CADR EXP) VPR))) (QUOTE P))))
	       (T (APPEND (COMPEXP (CADR EXP) M VPR) (QUOTE ((HRRZ@ 1 1)))))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT))
	     (EQ (CAR EXP) (QUOTE EQ)))
	 ((LAMBDA(L1 L2)
	   (APPEND (COMBOOL EXP M L1 NIL VPR)
		   (LIST (QUOTE (MOVEI 1 (QUOTE T))) (LIST (QUOTE JRST) 0 L2) L1 (QUOTE (MOVEI 1 0)) L2)))
	  (GENSYM1)
	  (GENSYM1)))
	((EQ (CAR EXP) (QUOTE COND)) (COMCOND (CDR EXP) M (GENSYM1) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE)) (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 (APPEND (COMPLISA (CDR EXP) M VPR)
		 (LIST (LIST (QUOTE CALL) (LENGTH (CDR EXP)) (LIST (QUOTE E) (CAR EXP))))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (APPEND (STACKUP (CDR EXP) M VPR)
		   (COMPEXP (CADDAR EXP) (DIFFERENCE M N) (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		   (SUBSTACK N)))
	  (LENGTH (CDR EXP))))
	((QUOTE T) (QUOTE NIL))))
EXPR)

(DEFPROP STACKUP
 (LAMBDA(U M VPR)
  (COND	((NULL U) NIL)
	(T (APPEND (COMPEXP (CAR U) M VPR) (QUOTE ((PUSH P 1))) (STACKUP (CDR U) (DIFFERENCE M 1) VPR)))))
EXPR)

(DEFPROP CCCHAIN
 (LAMBDA(EXP)
  (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR))) (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))
EXPR)

(DEFPROP COMPC
 (LAMBDA(EXP N2 M VPR)
  (COND	((ATOM EXP) (ERR (QUOTE COMPC)))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST (LIST (QUOTE HLRZ@) N2 (PLUS M (CDR (ASSOC* (CADR EXP) VPR))) (QUOTE P))))
	       (T (CONS (LIST (QUOTE HLRZ@) N2 N2) (COMPC (CADR EXP) N2 M VPR)))))
	((ATOM (CADR EXP)) (LIST (LIST (QUOTE HRRZ@) N2 (PLUS M (CDR (ASSOC* (CADR EXP) VPR))) (QUOTE P))))
	(T (CONS (LIST (QUOTE HRRZ@) N2 N2) (COMPC (CADR EXP) N2 M VPR)))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST L))
	((AND (NOT (ATOM (CAAR U))) (EQ (CAAAR U) (QUOTE NULL)) (NULL (CADAR U)))
	 (APPEND (COMPEXP (CADAAR U) M VPR) (LIST (LIST (QUOTE JUMPE) 1 L)) (COMCOND (CDR U) M L VPR)))
	((EQ (CAAR U) (QUOTE T)) (APPEND (COMPEXP (CADAR U) M VPR) (LIST L)))
	(T
	 ((LAMBDA(L1)
	   (APPEND (COMBOOL (CAAR U) M L1 NIL VPR)
		   (COMPEXP (CADAR U) M VPR)
		   (LIST (LIST (QUOTE JRST) 0 L) L1)
		   (COMCOND (CDR U) M L VPR)))
	  (GENSYM1)))))
EXPR)

(DEFPROP COMPLISA
 (LAMBDA(U M VPR)
  ((LAMBDA(Z)
    (APPEND (COMPLIS Z M 1 VPR)
	    (LOADAC Z (DIFFERENCE 1 (CCOUNT Z)) 1 (DIFFERENCE M (CCOUNT Z)) VPR)
	    (SUBSTACK (CCOUNT Z))))
   (CLASSIFY U)))
EXPR)

(DEFPROP CCOUNT
 (LAMBDA (Z) (COND ((NULL Z) 0) ((EQ (CAAR Z) 4) (PLUS 1 (CCOUNT (CDR Z)))) (T (CCOUNT (CDR Z)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(Z M2 N2 M VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 1)
	 (CONS (LIST (QUOTE MOVE) N2 (PLUS M (CDR (ASSOC* (CDAR Z) VPR))) (QUOTE P))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 0)
	 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z))) (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 2) (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z)) (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 3) (APPEND (REVERSE (COMPC (CDAR Z) N2 M VPR)) (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 5) (LOADAC (CDR Z) 1 (PLUS N2 1) M VPR))
	(T (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P)) (LOADAC (CDR Z) (PLUS M2 1) (PLUS N2 1) M VPR)))))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(Z M K VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 4)
	 (APPEND (COMPEXP (CDAR Z) M VPR)
		 (QUOTE ((PUSH P 1)))
		 (COMPLIS (CDR Z) (DIFFERENCE M 1) (PLUS K 1) VPR)))
	((EQ (CAAR Z) 5)
	 (APPEND (COMPEXP (CDAR Z) M VPR) (COND ((EQ K 1) NIL) (T (LIST (LIST (QUOTE MOVE) K 1))))))
	(T (COMPLIS (CDR Z) M (PLUS K 1) VPR))))
EXPR)

(DEFPROP CLASSIFY
 (LAMBDA (U) (CLASS2 (CLASS1 U NIL) NIL T))
EXPR)

(DEFPROP CLASS1
 (LAMBDA(U V)
  (COND	((NULL U) V)
	((ATOM (CAR U))
	 (COND ((OR (EQUAL (CAR U) (QUOTE NIL)) (EQUAL (CAR U) (QUOTE T)) (NUMBERP (CAR U)))
		(CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
	       (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
	((EQUAL (CAAR U) (QUOTE QUOTE)) (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
	((CCCHAIN (CAR U)) (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
	(T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))
EXPR)

(DEFPROP CLASS2
 (LAMBDA(U V FLG)
  (COND	((NULL U) V)
	((AND FLG (EQ (CAAR U) 4)) (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
	(T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))
EXPR)

(DEFPROP MKJRST
 (LAMBDA (L) (LIST (LIST (QUOTE JRST) 0 L)))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((EQ P (QUOTE T)) (COND (FLG (MKJRST L)) (T NIL)))
	((ATOM P) (APPEND (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))
	((EQ (CAR P) (QUOTE EQ))
	 (APPEND (COMPLISA (CDR P) M VPR)
		 (COND (FLG (QUOTE ((CAMN 1 2)))) (T (QUOTE ((CAME 1 2)))))
		 (MKJRST L)))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T ((LAMBDA (L1) (APPEND (COMPANDOR1 (CDR P) M L1 L NIL VPR) (LIST L1))) (GENSYM1)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T ((LAMBDA (L1) (APPEND (COMPANDOR1 (CDR P) M L1 L T VPR) (LIST L1))) (GENSYM1)))))
	((EQ (CAR P) (QUOTE NOT)) (COMBOOL (CADR P) M L (NOT FLG) VPR))
	((EQ (CAR P) (QUOTE NULL))
	 (APPEND (COMPEXP (CADR P) M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPE)) (T (QUOTE JUMPN))) 1 L))))
	(T (APPEND (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND ((NULL U) NIL) (T (APPEND (COMBOOL (CAR U) M L FLG VPR) (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)

(DEFPROP COMPANDOR1
 (LAMBDA(U M L L2 FLG VPR)
  (COND	((NULL U) (MKJRST L2))
	((NULL (CDR U)) (COMBOOL (CAR U) M L2 (NOT FLG) VPR))
	(T (APPEND (COMBOOL (CAR U) M L FLG VPR) (COMPANDOR1 (CDR U) M L L2 FLG VPR)))))
EXPR)

(DEFPROP GENSYM1
 (LAMBDA NIL (LIST (QUOTE LABEL) (GENSYM)))
EXPR)

(DEFPROP FLAT
 (LAMBDA (U S) (COND ((ATOM (CAR U)) (CONS U S)) (T (FLAT (CAR U) (FLAT (CDR U) S)))))
EXPR)